home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / plap.lisp < prev    next >
Lisp/Scheme  |  1992-07-21  |  13KB  |  370 lines
  1. ;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; The portable implementation of the LAP assembler.
  32. ;;;
  33. ;;; The portable implementation of the LAP assembler works by translating
  34. ;;; LAP code back into Lisp code and then compiling that Lisp code.  Note
  35. ;;; that this implementation is actually going to get a lot of use.  Some
  36. ;;; implementations (KCL) won't implement a native LAP assembler at all.
  37. ;;; Other implementations may not implement native LAP assemblers for all
  38. ;;; of their ports.  All of this implies that this portable LAP assembler
  39. ;;; needs to generate the best code it possibly can.
  40. ;;; 
  41.  
  42.  
  43. ;;;
  44. ;;; 
  45. ;;;
  46.  
  47. (defmacro lap-case (operand &body cases)
  48.   (once-only (operand)
  49.     `(ecase (car ,operand)
  50.        ,@(mapcar #'(lambda (case)
  51.              `(,(car case)
  52.                (apply #'(lambda ,(cadr case) ,@(cddr case))
  53.                   (cdr ,operand))))
  54.          cases))))
  55.  
  56. (defvar *lap-args*)
  57. (defvar *lap-rest-p*)
  58. (defvar *lap-i-regs*)
  59. (defvar *lap-v-regs*)
  60. (defvar *lap-fv-regs*)
  61. (defvar *lap-t-regs*)
  62.  
  63. (defvar *lap-optimize-declaration* '#.*optimize-speed*)
  64.  
  65.  
  66. (eval-when (load eval)
  67.   (setq *make-lap-closure-generator*
  68.     #'(lambda (closure-var-names arg-names index-regs 
  69.            vector-regs fixnum-vector-regs t-regs lap-code)
  70.         (compile-lambda
  71.           (make-lap-closure-generator-lambda
  72.         closure-var-names arg-names index-regs 
  73.         vector-regs fixnum-vector-regs t-regs lap-code)))
  74.  
  75.     *precompile-lap-closure-generator*
  76.     #'(lambda (cvars args i-regs v-regs fv-regs t-regs lap)
  77.         `(function
  78.            ,(make-lap-closure-generator-lambda cvars args i-regs 
  79.          v-regs fv-regs t-regs lap)))
  80.     *lap-in-lisp*
  81.     #'(lambda (cvars args iregs vregs fvregs tregs lap)
  82.         (declare (ignore cvars args))
  83.         (make-lap-prog
  84.           iregs vregs fvregs tregs 
  85.           (flatten-lap lap ;(opcode :label 'exit-lap-in-lisp)
  86.                )))))
  87.  
  88. (defun make-lap-closure-generator-lambda (cvars args i-regs v-regs fv-regs t-regs lap)
  89.   (let* ((rest (memq '&rest args))
  90.      (ldiff (and rest (ldiff args rest))))
  91.     (when rest (setq args (append ldiff '(&rest .lap-rest-arg.))))
  92.     (let* ((*lap-args* (if rest ldiff args))
  93.        (*lap-rest-p* (not (null rest))))
  94.       `(lambda ,cvars
  95.      #'(lambda ,args
  96.          #-CMU (declare ,*lap-optimize-declaration*)
  97.          #-CMU ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)
  98.          #+CMU
  99.              ;;
  100.              ;; Use LOCALLY instead of a declare on the lambda so that we don't
  101.              ;; suppress arg count checking...
  102.              (locally (declare ,*lap-optimize-declaration*)
  103.            ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)))))))
  104.  
  105. (defun make-lap-prog (i-regs v-regs fv-regs t-regs lap)
  106.   (let* ((*lap-args* 'lap-in-lisp)
  107.      (*lap-rest-p* 'lap-in-lisp))
  108.     (make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)))
  109.  
  110. (defun make-lap-prog-internal (i-regs v-regs fv-regs t-regs lap)
  111.   (let* ((*lap-i-regs* i-regs)
  112.      (*lap-v-regs* v-regs)
  113.      (*lap-fv-regs* fv-regs)
  114.      (*lap-t-regs* t-regs)
  115.      (code (mapcar #'lap-opcode lap)))
  116.     `(prog ,(mapcar #'(lambda (reg)
  117.             `(,(lap-reg reg)
  118.               ,(lap-reg-initial-value-form reg)))
  119.             (append i-regs v-regs fv-regs t-regs))
  120.        (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
  121.             (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
  122.             (type #+structure-wrapper cache-number-vector
  123.                   #-structure-wrapper (simple-array fixnum)
  124.                   ,@(mapcar #'lap-reg *lap-fv-regs*))
  125.                 #-cmu ,*lap-optimize-declaration*)
  126.        ,.code)))
  127.  
  128. (defvar *empty-vector* '#())
  129. (defvar *empty-fixnum-vector*
  130.   (make-array 8
  131.           :element-type 'fixnum
  132.           :initial-element 0))
  133.  
  134. (defun lap-reg-initial-value-form (reg)
  135.   (cond ((member reg *lap-i-regs*) 0)
  136.         ((member reg *lap-v-regs*) '*empty-vector*)
  137.         ((member reg *lap-fv-regs*) '*empty-fixnum-vector*)
  138.         ((member reg *lap-t-regs*) nil)
  139.         (t
  140.          (error "What kind of register is ~S?" reg))))
  141.  
  142. (defun lap-opcode (opcode)    
  143.   (lap-case opcode
  144.     (:move (from to)
  145.      `(setf ,(lap-operand to) ,(lap-operand from)))
  146.       
  147.     ((:eq :neq :fix=) (arg1 arg2 label)
  148.      `(when ,(lap-operands (ecase (car opcode)
  149.                  (:eq 'eq) (:neq 'neq) (:fix= 'RUNTIME\ FIX=))
  150.                arg1
  151.                arg2)
  152.     (go ,label)))
  153.  
  154.     ((:izerop) (arg label)
  155.      `(when ,(lap-operands 'RUNTIME\ IZEROP arg)
  156.     (go ,label)))
  157.  
  158.     (:std-instance-p (from label)
  159.      `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label)))
  160.     (:fsc-instance-p (from label)
  161.      `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label)))
  162.     (:built-in-instance-p (from label)
  163.      (declare (ignore from))
  164.      `(when ,t (go ,label)))                            ;***
  165.     (:structure-instance-p (from label)
  166.      `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label)))    ;***
  167.     
  168.     ((:jmp :emf-call) (fn)
  169.      (if (eq *lap-args* 'lap-in-lisp)
  170.      (error "Can't do a :JMP in LAP-IN-LISP.")
  171.      `(return
  172.         ,(if (eq (car opcode) :jmp)
  173.          (if *lap-rest-p*
  174.              `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.)
  175.              `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*))
  176.          `(RUNTIME\ EMF-CALL ,(lap-operand fn) ,*lap-rest-p* ,@*lap-args*
  177.                              ,@(when *lap-rest-p* `(.lap-rest-arg.)))))))
  178.  
  179.     (:return (value)
  180.      `(return ,(lap-operand value)))
  181.       
  182.     (:label (label) label)
  183.     (:go   (label)  `(go ,label))
  184.  
  185.     (:exit-lap-in-lisp () `(go exit-lap-in-lisp))
  186.     
  187.     (:break ()      `(break))
  188.     (:beep  ()      #+Genera`(zl:beep))
  189.     (:print (val)   (lap-operands 'print val))
  190.     ))
  191.  
  192. (defun lap-operand (operand)
  193.   (lap-case operand
  194.     (:reg (n) (lap-reg n))
  195.     (:cdr (reg) (lap-operands 'cdr reg))
  196.     ((:cvar :arg) (name) name)
  197.     (:constant (c) `',c)
  198.     ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper
  199.       :built-in-or-structure-wrapper :std-slots :fsc-slots
  200.       :wrapper-cache-number-vector)
  201.      (x)
  202.      (lap-operands (ecase (car operand)
  203.              (:std-wrapper       'RUNTIME\ STD-WRAPPER)
  204.              (:fsc-wrapper       'RUNTIME\ FSC-WRAPPER)
  205.              (:built-in-wrapper  'RUNTIME\ BUILT-IN-WRAPPER)
  206.              (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER)
  207.              (:built-in-or-structure-wrapper
  208.                                  'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER)
  209.              (:std-slots         'RUNTIME\ STD-SLOTS)
  210.              (:fsc-slots         'RUNTIME\ FSC-SLOTS)
  211.              (:wrapper-cache-number-vector 
  212.               'RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR))
  213.            x))
  214.     
  215.      
  216.     (:i1+     (index)         (lap-operands 'RUNTIME\ I1+ index))
  217.     (:i+      (index1 index2) (lap-operands 'RUNTIME\ I+ index1 index2))
  218.     (:i-      (index1 index2) (lap-operands 'RUNTIME\ I- index1 index2))
  219.     (:ilogand (index1 index2) (lap-operands 'RUNTIME\ ILOGAND index1 index2))
  220.     (:ilogxor (index1 index2) (lap-operands 'RUNTIME\ ILOGXOR index1 index2))
  221.     
  222.     (:iref    (vector index)       (lap-operands 'RUNTIME\ IREF vector index))
  223.     (:iset    (vector index value) (lap-operands 'RUNTIME\ ISET vector index value))
  224.  
  225.     (:instance-ref (vector index)
  226.            (lap-operands 'RUNTIME\ INSTANCE-REF vector index))
  227.     (:instance-set (vector index value)
  228.            (lap-operands 'RUNTIME\ INSTANCE-SET vector index value))
  229.  
  230.     (:cref   (vector i)       `(RUNTIME\ SVREF ,(lap-operand vector) ,i))
  231.     (:lisp-variable (symbol) symbol)
  232.     (:lisp          (form)   form)
  233.     ))
  234.  
  235. (defun lap-operands (fn &rest regs)
  236.   (cons fn (mapcar #'lap-operand regs)))
  237.  
  238. (defun lap-reg (n) (intern (format nil "REG~D" n) *the-pcl-package*))
  239.  
  240.  
  241. ;;;
  242. ;;; Runtime Implementations of the operands and opcodes.
  243. ;;;
  244. ;;; In those ports of PCL which choose not to completely re-implement the
  245. ;;; LAP code generator, it may still be provident to consider reimplementing
  246. ;;; one or more of these to get the compiler to produce better code.  That
  247. ;;; is why they are split out.
  248. ;;; 
  249. (proclaim '(declaration pcl-fast-call))
  250.  
  251. (defmacro RUNTIME\ FUNCALL (fn &rest args)
  252.   #+CMU `(funcall (the function ,fn) ,.args)
  253.   #-CMU `(funcall ,fn ,.args))
  254.  
  255. (defmacro RUNTIME\ APPLY (fn &rest args)
  256.   #+CMU `(apply (the function ,fn) ,.args)
  257.   #-CMU `(apply ,fn ,.args))
  258.  
  259. (defmacro RUNTIME\ EMF-CALL (emf restp &rest required-args+rest-arg)
  260.   `(invoke-effective-method-function ,emf ,restp ,@required-args+rest-arg))
  261.  
  262. (defmacro RUNTIME\ STD-WRAPPER (x)
  263.   `(std-instance-wrapper ,x))
  264.  
  265. (defmacro RUNTIME\ FSC-WRAPPER (x)
  266.   `(fsc-instance-wrapper ,x))
  267.  
  268. (defmacro RUNTIME\ BUILT-IN-WRAPPER (x)
  269.   `(built-in-wrapper-of ,x))
  270.  
  271. (defmacro RUNTIME\ STRUCTURE-WRAPPER (x)
  272.   `(built-in-or-structure-wrapper ,x))
  273.  
  274. (defmacro RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER (x)
  275.   `(built-in-or-structure-wrapper ,x))
  276.  
  277. (defmacro RUNTIME\ STRUCTURE-INSTANCE-P (x)
  278.   `(structure-instance-p ,x))
  279.  
  280. (defmacro RUNTIME\ STD-SLOTS (x)
  281.   `(std-instance-slots (the std-instance ,x)))
  282.  
  283. (defmacro RUNTIME\ FSC-SLOTS (x)
  284.   `(fsc-instance-slots ,x))
  285.  
  286. (defmacro RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR (x)
  287.   `(wrapper-cache-number-vector ,x))
  288.  
  289. (defmacro RUNTIME\ STD-INSTANCE-P (x)
  290.   `(std-instance-p ,x))
  291.  
  292. (defmacro RUNTIME\ FSC-INSTANCE-P (x)
  293.   `(fsc-instance-p ,x))
  294.  
  295. (defmacro RUNTIME\ IZEROP (x)
  296.   `(zerop (the fixnum ,x)))
  297.  
  298. (defmacro RUNTIME\ FIX= (x y)
  299.   `(= (the fixnum ,x) (the fixnum ,y)))
  300.  
  301. ;;;
  302. ;;; These are the implementations of the index operands.  The portable
  303. ;;; assembler generates Lisp code that uses these macros.  Even though
  304. ;;; the variables holding the arguments and results have type declarations
  305. ;;; on them, we put type declarations in here.
  306. ;;;
  307. ;;; Some compilers are so stupid...
  308. ;;;
  309. (defmacro RUNTIME\ IREF (vector index)
  310.   #-structure-wrapper
  311.   `(svref (the simple-vector ,vector) (the fixnum ,index))
  312.   #+structure-wrapper
  313.   `(aref ,vector (the fixnum ,index)))
  314.  
  315. (defmacro RUNTIME\ ISET (vector index value)
  316.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value))
  317.  
  318. (defmacro RUNTIME\ INSTANCE-REF (vector index)
  319.   #-new-kcl-wrapper
  320.   `(svref (the simple-vector ,vector) (the fixnum ,index))
  321.   #+new-kcl-wrapper
  322.   `(%instance-ref ,vector (the fixnum ,index)))
  323.  
  324. (defmacro RUNTIME\ INSTANCE-SET (vector index value)
  325.   #-new-kcl-wrapper
  326.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)
  327.   #+new-kcl-wrapper
  328.   `(setf (%instance-ref ,vector (the fixnum ,index)) ,value))
  329.  
  330. (defmacro RUNTIME\ SVREF (vector fixnum)
  331.   #-structure-wrapper
  332.   `(svref (the simple-vector ,vector) (the fixnum ,fixnum))
  333.   #+structure-wrapper
  334.   `(aref ,vector (the fixnum ,fixnum)))
  335.  
  336. (defmacro RUNTIME\ I+ (index1 index2)
  337.   `(the fixnum (+ (the fixnum ,index1) (the fixnum ,index2))))
  338.  
  339. (defmacro RUNTIME\ I- (index1 index2)  
  340.   `(the fixnum (- (the fixnum ,index1) (the fixnum ,index2))))
  341.  
  342. (defmacro RUNTIME\ I1+ (index)
  343.   `(the fixnum (1+ (the fixnum ,index))))
  344.  
  345. (defmacro RUNTIME\ ILOGAND (index1 index2)
  346.   #-Lucid `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2)))
  347.   #+Lucid `(%logand ,index1 ,index2))
  348.  
  349. (defmacro RUNTIME\ ILOGXOR (index1 index2)
  350.   `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2))))
  351.  
  352. ;;;
  353. ;;; In the portable implementation, indexes are just fixnums.
  354. ;;; 
  355.  
  356. (defconstant index-value-limit most-positive-fixnum)
  357.  
  358. (defun index-value->index (index-value) index-value)
  359. (defun index->index-value (index) index)
  360.  
  361. (defun make-index-mask (cache-size line-size)
  362.   (let ((cache-size-in-bits (floor (log cache-size 2)))
  363.     (line-size-in-bits (floor (log line-size 2)))
  364.     (mask 0))
  365.     (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask)))
  366.     (dotimes (i line-size-in-bits)  (setq mask (dpb 0 (byte 1 i) mask)))
  367.     mask))
  368.  
  369.  
  370.